perm filename DIRECT.9[AID,LSP] blob
sn#451938 filedate 1979-06-17 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00003 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (declare (eval (read)))
C00008 00003 (eval-when (load eval) (require defsym 1 dsk (mac lsp)))
C00020 ENDMK
C⊗;
(declare (eval (read)))
(setsyntax '/[ 'splicing ;conditional assemble hack
(function (lambda nil ;looks sort of like Midas IF's
((lambda (if flag r)
(cond ((atom flag)(setq flag (ncons flag))))
(cond ((eq if 'ife))
((eq if 'ifn) (setq if nil))
((eq if 'ifp) (setq if (eval flag) flag nil))
((break losing-if t)))
(or (apply 'and (mapcar (function (lambda (q)
(cond ((atom q)
(cond ((memq q r) t)))
(t (cond ((apply (car q)
(ncons (memq (cadr q) r))) t))))))
flag))
(setq if (not if)))
(and if (do ((z (tyipeek) (tyipeek)) (n 1))
((zerop n))
(cond ((= z 91.) (setq n (1+ n)))
((= z 93.) (setq n (1- n))))(tyi))))
(read) (read)(status features))
nil)))
(declare (eval (read)))
(setsyntax '/] 'splicing (function (lambda nil nil))) ;right brace
;;; Directory hacking package
(defun dir fexpr (file)
(declare (fixnum n))
((lambda (n)
(cond ((zerop n) (apply 'direct (status udir)))
((= n 1) (apply 'direct (list (car file) (cadr (status uname)))))
(t (apply 'direct file))))
(length file)))
[IFN NEWIO
(defun ugreat1 (specs)
(cond ((eq (cadr (cdr specs)) '/>)
(list (car specs) (cadr specs) (apply 'ugreat (cons (cadr specs)
(cadr (car specs))))))
(t specs)))]
(defun ugreat fexpr (specs)
(declare (fixnum n j))
((lambda (best best-ext filename base ibase)
(mapc (function (lambda (entry)
(and (eq (car entry) filename)
((lambda (ext)
(cond ((and ext
(numberp ext))
(cond ((numberp best)
(cond ((> ext best)
(setq best ext best-ext (cadr entry)))))
(t (setq best ext best-ext (cadr entry)))))))
(readlist (explodec (cadr entry)))))))
(apply 'direct (cdr specs))) best-ext)
nil nil ((lambda (n)
(cond ((< 6 n)
(do ((i (nreverse (explode (car specs)))
(cdr i))
(j (- n 6) (1- j)))
((zerop j) (implode (nreverse i)))))
(t (car specs))))
(length (explode (car specs)))) 10. 10.))
(defun urename1 fexpr (specs)
(declare (fixnum n j))
(cond ((eq (cadr specs) '/>)
(setq specs ((lambda (crunit)
(list (car specs) (car crunit)(cadr crunit)))
(cadr (crunit))))
((lambda (best best-ext filename base ibase *nopoint)
(mapc (function (lambda (entry)
(and (eq (car entry) filename)
((lambda (ext)
(cond ((and ext
(numberp ext))
(cond ((numberp best)
(cond ((> ext best)
(setq best ext best-ext (cadr entry)))))
(t (setq best ext best-ext (cadr entry)))))))
(readlist (explodec (cadr entry)))))))
(apply 'direct (cdr specs))) (apply 'ufile
(list (car specs)
(implode
(explodec
(cond ((numberp best)(1+ best))
(t 1)))))))
nil nil ((lambda (n)
(cond ((< 6 n)
(do ((i (nreverse (explode (car specs)))
(cdr i))
(j (- n 6) (1- j)))
((zerop j) (implode (nreverse i)))))
(t (car specs))))
(length (explode (car specs)))) 10. 10. t))
(t (apply 'ufile specs))))
;(eval-when (load eval) (require defsym 1 dsk (mac lsp)))
(LAP DIRECT SUBR)
(ARGS DIRECT (NIL . 2))
;(defsym chntb 222)
[IFE NEWIO
;(defsym read6c 434010)] ;in ulap read6c should now be define
(setzm 0 mfd) ;handle 1,1 separately
(push p b)
(pushj p sixmak) ;make p into sixbit
(pushj p just)
(push fxp tt) ;save
(pop p a) ;pn
(pushj p sixmak) ;6-bit
(pushj p just)
(move a tt)
[IFN NEWIO
(move tt point)
loop1
(move b 0 tt)
(jumpe b found)
(aobjn tt loop1)
(lerr 0 (% sixbit |No channels available!|))
found
(hrrzs 0 tt)
(subi tt chntb)
(movei d 0 tt)
(movem d chnn)
(lsh tt 27)
(movem tt chn)
(addi d chntb)
(movsi tt 400000)
(movem tt 0 d)]
(movei tt 17) ;dump mode
(hrlzi d (sixbit / / / dsk)) ;device
(setz r)
[IFN NEWIO
(move b xopen)
(ior b chn)
(xct 0 b)] ;open a channel
[IFE NEWIO
(open 3 tt)]
(lerr 0 (% sixbit |Device not available!|))
(pop fxp tt)
(hlr tt a)
(camn tt oneone) ;1,1 ?
(aos 0 mfd)
(hrlzi d (sixbit / / / UFD))
(setz r)
(move f oneone) ;[1,1]
[IFN NEWIO
(move b xlookup)
(ior b chn)
(xct 0 b)] ;lookup ufd
[IFE NEWIO
(lookup 3 tt)]
(jrst 0 noufd) ;no ufd returns nil
(push p (% 0 0 'nil)) ;this is mapcar-like hackery
(movei a 0 p) ;keeping a pointer to the head and tail
(push p a)
(setzm 0 end) ;end of ufd flag
next
(movei r 200) ;for reading 8 ufd entries at once
(movei d ufd) ;pointer to ufd buffer
(setzm 0 ufd) ;zero first word for blt hack
(hrlzi b ufd)
(hrri b (+ ufd 1))
(blt b (+ ufd 177)) ;zero buffer
(move t mfd)
(xct 0 tbl1 t) ;read a bufferful
loop
(skipn 0 0 d) ;filename entry = 0 => non-∃ entry
(jrst 0 quit) ;so see if we're done
(move t mfd) ;mfd offset
(xct 0 tbl2 t) ;put second item in work
(push fxp r) ;well, save the counters
(push fxp d)
(skipn 0 work) ;no extension
(jrst 0 noext) ;so stick nil as answer
(move a bp) ;silly byte pointer (faslap bug)
(xct 0 tbl3 t) ;set up byte pointer
(pushj p read6c) ;use reader to make atom and intern
(jsp t %ncons) ;make up (ext)
filen
(push fxp a) ;stash on stack
(move d -1 fxp)
(move a 0 d) ;now filename
(move t mfd)
(xct 0 tbl4 t) ;first thing in work + byte pointer
(pushj p read6c)
(pop fxp b) ;filename in a
(jsp t %cons) ;(p pn)
(jsp t %ncons) ;((p pn))
(hrrm a @ 0 p) ;rplacd onto end
(movem a 0 p) ;back on stack
(pop fxp d)
(pop fxp r)
quit
(subi r 20) ;well, see if we're done
(addi d 20) ;2 counters is extravagant, but dskio!
(move t mfd)
(xct 0 tbl5 t) ;move second thing into a
(jumpn r loop) ;go again
(skipn 0 end) ;end of ufd?
(jrst 0 next) ;next entry in ufd
(sub p (% 0 0 1 1)) ;flush end of list pointer
(pop p a) ;the answer
[IFN NEWIO
(move b xrelease)
(ior b chn)
(xct 0 b) ;free up channel
(move b chnn)
(addi b chntb)
(setzm 0 0 b)]
[IFE NEWIO
(release 3 0)]
(popj p) ;return
sailfn
(move tt a)
(ildb t a)
(caie t)
(popj p)
(ibp 0 tt)
(jrst 0 (+ sailfn 1))
noufd
(movei a 'nil) ;no ufd => nil
(release 3 0)
(popj p) ;return
setnb
(setom 0 end) ;end of ufd coming up
(move a 1 d) ;next entry loaded
(popj p)
setnb1
(setom 0 end) ;end of ufd coming up
(move a 0 d) ;next entry loaded
(popj p)
noext
(movei a 'nil) ;no extension => nil
(jrst 0 filen) ;do filename
SIXMAK (MOVEI B '6) ;direct lift from faslap
(CALL 2 'PNGET)
(HLRZ A 0 A)
(MOVE TT 0 A)
(POPJ P)
JUST (TLNE TT 77)
(POPJ P)
(LSH TT -6)
(JRST 0 JUST)
IOWD (777600←22 0 (- UFD 1)) ;dump mode command list
(0)
mfd (0)
bp (440600←22 0 WORK) ;silly byte pointer due to faslap bug
WORK (BLOCK 2) ;working space for read6c
end (0)
oneone (sixbit / / 1/ / 1)
UFD (BLOCK 200) ;dump buffer
;;; Silly table lookup stuff to do ufd's and the mfd separately, though sharing stuff.
tbl1
(pushj p utbl1)
(pushj p mtbl1)
tbl2
(hlrzm a work) ;puts the filename in work
(hrrzm a work) ;puts pn in work
tbl3
(hrli a 220600) ;fix losing bp for ext
(pushj p mtbl3) ;fixup bp using sailfn
tbl4
(pushj p utbl4) ;loads work + bp for filename
(pushj p mtbl4) ;loads work + bp for p
tbl5
(move a 1 d) ;load next entry extension
(move a 0 d) ;load first entry again
utbl1
[IFN NEWIO
(move b in1)
(ior b chn)
(xct 0 b)] ;get an entry
[IFE NEWIO
(in 3 tt)]
(skipa a 1 d) ;a bum to get the ext in a
(jrst 0 setnb) ;set end of ufd flag unusual case
(popj p)
mtbl1
[IFN NEWIO
(move b in2)
(ior b chn)
(xct 0 b)] ;get an entry
[IFE NEWIO
(in 3 tt)]
(skipa a 0 d)
(jrst 0 setnb1)
(popj p)
mtbl3
(pushj p sailfn) ;fixes bp
(move a tt) ;loads corrected bp
(popj p)
utbl4
(movem a work)
(move a bp)
(popj p)
mtbl4
(hlrzm a work)
(move a bp)
(pushj p sailfn)
(move a tt)
(popj p)
[IFN NEWIO
xopen (open 0 tt)
xlookup (lookup 0 tt)
xrelease (release 0 0)
in1
in2 (in 0 iowd)
chn (0)
chnn (0)
point (77776←25 0 chntb)] ;-20,,chntb
NIL